home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Class < prev    next >
Encoding:
Text File  |  1995-11-23  |  18.2 KB  |  632 lines  |  [TEXT/YERK]

  1. \ Class/Object general properties and compilation code
  2. \  4/26/84  CBD Version 1.0
  3. \  4/26/84  CBD Speeded up ^Elem and friends
  4. \  4/27/84  CBD Moved rect, etc. to QD  file
  5. \  5/02/84  CBD Removed IX-non-IX restriction
  6. \  5/24/84  NDI Remove selector numbering, add objlen
  7. \  5/26/84  CBD Took non-class stuff out
  8. \  5/28/84  CBD Selectors defer refs to input parm objects
  9. \ 10/04/84  CBD Added class initialization, text messages
  10. \ 10/11/84  CBD objPtr and objArray support
  11. \ 10/12/84  CBD Added GET: and PUT: for arrays
  12. \ 10/18/84  CBD converted to mcfa Values
  13. \ 10/30/84  CBD propagate classInit: thru Ivar chains at create
  14. \ 11/02/84  CBD objects have executable CFA
  15. \ 11/02/84  CBD update for optimized array support in nucleus
  16. \ 11/16/84  CBD removed objArray, etc.
  17. \ 12/08/84  CBD ß1.0 version
  18. \ 12/14/84  cbd removed read:, write:, etc
  19. \ 12/15/84  cbd hashed selectors
  20. \ 12/12/85  cdn Put CR after redefined message in :M
  21. \  8/01/86  cdn Added "Method redefined, within same class ****" message
  22. \ 12/27/89    rfl    changed ?isclass to check for valid ram for @
  23. \  1/11/90    rfl    need to change traverse or at least ?cfa in nuc to protect for valid ram
  24. \ 11/23/90    rfl    Method redefined message now comes before selector for readability
  25. \ 12/17/90    rfl    added class name to above
  26. \  6/01/91    rfl    ovblock modified for sys 7...heap is below 0;
  27. \ 12/12/92    rfl 32 bit hash for methods; move ?rdepth to this source
  28. \ 12/25/92    rfl    changed nuc to set heapBot, heapTop in relative addr space
  29. \ 12/26/92    rfl object name not unique error gives name of object
  30. \  5/28/93    rfl    added within and used it in (@)
  31. \  6/04/93    rfl    modified (build) for source documentation (line#..)
  32. \  3/03/94    rfl ;class now handles smudge so classes can be redefined with same name
  33. \ 11/11/95    rfl    exit moved to this class...now works with methods
  34. \ 11/23/95    rfl    modified :M to use verbose
  35. 0 value (rdepth)
  36. : +rdepth 1 -> (rdepth) ;
  37. : -rdepth 0 -> (rdepth) ;
  38. : ?Rdepth (rdepth) IF  rdepth  220 > ?error 116 THEN ;
  39.  
  40. : +docs true -> docs ;
  41. : -docs false -> docs ;
  42.  
  43. : ^CLASS   current  @ pfa ;
  44.  
  45. \ the following offsets refer to the ^class, or Pfa of the class.
  46. : MFA    10 + ;    \ methods dictionary Latest field
  47. : IFA    14 + ;    \ ivar dict Latest field
  48. : DFA    18 + ;    \ Datalen , width of indexed area
  49. : SFA    22 + ;    \ superclass ptr field
  50.  
  51. \ Get length of object's named ivars
  52. : @DLEN cfa @ Dfa  W@   ;
  53.  
  54. \ ( SelPfa ^class -- m1cfa )  Find a method in a class
  55. : (FINDM)
  56.     swap over mfa ((findm))  0=
  57.     IF  cr msg# 108  nfa .name
  58.         abort
  59.     ELSE  swap drop THEN ;
  60.  
  61. \ ( Selhash objPfa -- objPfa m1cfa )
  62. \  Find a method 1cfa given a selector ID
  63. : FIND-METHOD
  64.     dup 0= ?error 103
  65.     swap over CFA @ (FINDM)  ;
  66.  
  67. \ ( objAddr -- )  Look up SelID at IP and run the method
  68. : (Defer)
  69.     w@(ip)    \ objPfa  selID
  70.     Swap  Find-Method Cfa    \ objAddr m0cfa
  71.     execute  ;    \ exec the  m0cfa
  72.  
  73.    0 Value  ^Self
  74.    0 Value  ^Super        \ nfa of SUPER pseudo-Ivar
  75.    0 Value  newObject    \ object being created
  76.    1 Value  rangeCheck    \ true if runtime range check desired
  77. true Value dEcho        \ echo load to screen?
  78.  
  79. 0 -> quitvec    \ clear vectors
  80. 0 -> abortvec
  81. 0 -> objInit
  82. 'c pfind -> ufind
  83.  
  84. \ ( addr -- hashVal )  hash a  name into a 16-bit word
  85. : Hash { addr -- }
  86.     0 addr count +  addr
  87.     DO 4* Dup 65535 > IF 1+ THEN
  88.         I  C@ 32 - xor  65535 And
  89.     LOOP ;
  90.  
  91. : within { n lo hi -- b } n lo >= n hi <= and ;
  92.  
  93. \ check to make sure the memory addressed is within the application heap zone
  94. : (@) ( addr -- n t or f)  dup heapBot heapTop within
  95.     IF @ true ELSE drop false THEN ;
  96.  
  97. \ ( pfa -- pfa b )  returns true if a class -  make sure pfa points within appl
  98. : ?IsClass  'CODE DoClass OVER CFA (@) IF = ELSE drop false THEN ;
  99.  
  100. \ ( pfa -- pfa b )  return true if an object
  101. :f ?IsObj
  102.     ?IsClass
  103.     IF  False
  104.     ELSE Dup cfa (@)
  105.         IF ?IsClass swap drop ELSE false THEN 
  106.     THEN ;f
  107.  
  108. \ ( pfa -- pfa b )  return true if an object vector
  109. : ?IsVect  dup cfa (@) IF  valCode = over cfa @ vectCode = or ELSE false THEN ;
  110.  
  111. \ ( pfa -- pfa b )  is ref'd word an open bracket?
  112. : ?IsParen  dup nfa 1+ c@ ascii [ =  ;
  113.  
  114. \ ( -- )  ERROR if not compiling a new class definition
  115. : ?Class   Cstate   0=  ?error 115  ;
  116.  
  117. \ ( classIFA -- f OR 1cfa t )  search CLASS dictionaries
  118. : ivarFind   here hash swap ((findm))   ;
  119.  
  120. \ ( -- f OR pfa t )  Determine if  next word is an instance var
  121. : vFind
  122.     bl word  Cstate
  123.     IF    \ class compile?
  124.         ^class  IFA ivarFind    \ search IVAR chain
  125.     ELSE  0 THEN ;    \ leave ff
  126.  
  127. \ Key to instantiation actions
  128. \ notFnd    -not previously defined
  129. \ objTyp    -defined as an object
  130. \ classTyp    -as a class
  131. \ vecTyp    -as an object vector- ptr, array, etc
  132. \ parmTyp    -as a named parm
  133. \ parenType    -open paren for defer group
  134.  
  135. \ ( #elems ^class  OR ^class -- indlen )
  136. : IDX-HDR   DFA 2+ W@ DUP IF  2DUP W, W,  * align THEN ;
  137.  
  138. \ ( IVnfa -- ivlfa )
  139. : ilfa   2+ ;
  140.  
  141. \ ( ilfa -- icfa )
  142. : ^ICLASS  CFALEN + @ ;
  143.  
  144. \ ( ^class -- elWidth )  return the indexed element width for class
  145. : @width   dfa 2+ w@  ;
  146.  
  147. \ ( infa -- icfa )  transform ivar nfa to its class field
  148. : icfa  ilfa  4+  ;
  149.  
  150. \ ( ivarlfa -- #els  wid  idxOffs  tf OR ff )
  151.  
  152. \ ( ivarNfa -- IvarNfa b )  True if nfa is Super or Self
  153. : ?LastIvar         Dup  ^Self   = Over ^Super   = OR ;
  154.  
  155. \ InitIvar  performs the classInit: method on the ivar on the stack )
  156. Forward InitIvar
  157.  
  158. \ ( ivarNfa -- latestNfa )  -> Latest nested Ivar
  159. : ^LatestIvar    ilfa ^Iclass  IFA  @  ;
  160. : ^NextIvar      ILFA  @ ;
  161.  
  162. \ ( ivarnfa -- ivoffs )  Return ivar's offset
  163. : @IvarOffs  ILFA  8+ W@  ;
  164.  
  165. \ ( ivarNfa -- IvarNfa newNfa t  OR  ivarNfa f )
  166. : ?Nest
  167.     Dup ^LatestIvar  ?LastIvar
  168.     IF  Drop 0 ELSE 1 THEN ;
  169.  
  170. \ ITRAV traverses the tree of nested ivar definitions in a
  171. \ class, building necessary indexed area headers
  172. \ the Mstack has the base offset for nested Ivars
  173. \ ( ivarNfa -- )
  174. : ITRAV
  175.     BEGIN  ?Rdepth ?Nest
  176.         IF Over @IvarOffs Dupm Addm Itrav THEN
  177.         Dup
  178.         ILFA dup    \ DO-NODE - Build header if indexed ivar
  179.         pushm copym ^iclass -dup    \ HDR-INFO
  180.         IF  copym $ 0a + w@  popm 8+ w@   ( #els  offs )
  181.             rot dup dfa w@ rot + swap @width  ( #els truoffs wdth)
  182.             swap over -dup
  183.             IF ELSE 2drop drop 0 THEN
  184.         ELSE  dropm 0 THEN    \ not idx
  185.         IF  CopyM +    \ add in nested base offset
  186.             pushm copym newObject  + w!   ( ! el-width )
  187.             popm  newObject  +  2+ W!  ( !  # els )
  188.             dup 4+ @        \ get ^class of indexed Ivar
  189.             over 8+ w@        \ get offs this ivar
  190.             copym  newObject + + cfa !    \ store in cfa
  191.         THEN  initIvar
  192.         ^NextIvar  ?LastIvar  Not
  193.     WHILE  REPEAT
  194.     DROP DropM ;
  195.  
  196. Forward  ClassInit
  197.  
  198. \ ( #elems ^class OR ^class -- ) Compile an instance variable dictionary entry
  199. : <VAR
  200.     pushm    \ place ^class on methods stack for later
  201.     Vfind  ?error 117
  202.     here dup hash w,        \ compile hashed ivar name into dict
  203.     ^Class IFA dup @ ,  !  COPYM  ,  ( link, class )
  204.     copym @width
  205.     IF  4 ^class dfa w+! THEN    \ if indexed, save 4 for cfa
  206.     ^Class DFA  W@  W,            \  ( current dLen= offset )
  207.     copym @width dup
  208.     IF over * swap W, 4+ THEN  ( #elems)
  209.     popM DFA W@  +  align    \ Account for named ivar lengths
  210.     ^Class  DFA   W+!   ;
  211.  
  212. \ ( -- )  Create hdr for the name at Here
  213. : CreateHdr
  214.     Here 1+ c@ 0= ?error 118
  215.     $ 80 S, latest , current !  0,   ;
  216.  
  217. \ ( m1cfa n -- )  Execute the ncfa of word on stack
  218. \ takes a standard Pfa = 1cfa as input
  219. \ : mExec  clen * swap 4- + Execute ;
  220.  
  221. \ ( #elems ^class OR ^class -- )  Build an instance of a class
  222. : (BUILD)
  223.     Pushm  Cstate
  224.     IF  Popm  <Var    \ build an ivar
  225.     ELSE
  226.         \ NEWTOKEN : pulls name from stream
  227.         Here 1 and IF 0 c, THEN docs IF line# w, THEN Find
  228.         IF drop ?isVect
  229.             IF  3 ( vecTyp )
  230.             ELSE  1 ( objTyp )
  231.             THEN
  232.         ELSE 0 ( notFnd ) THEN    ( -- pfa type OR 0 )
  233.  
  234.         \ OBJHDR :
  235.         \ Build a public  object header or just a cfa if headerless
  236.         \ If an object vector, load pfa of object into vector
  237.         \ ( {vectPfa} objType -- )  HERE is left at pfa of new object
  238.         Select{    \ on object type
  239.             0 ( notFnd )    Is{  CreateHdr  }End    \ not redefined
  240.  
  241.             1 ( objTyp )    Is{  drop createHdr
  242.                 type# 181 ( Object name not unique ) latest id.  cr   }End
  243.  
  244.             2 ( classtyp )  Is{ abort }End        \ should not get this
  245.  
  246.             \ ( ind vecPfa -- )  for object vectors, execute -> code at 2cfa
  247.             3 ( vecTyp )   Is{  0, Here  swap 2 clen * swap 4- + Execute
  248.                 msg# 120  }End
  249.  
  250.         Default{ abort }Select
  251.  
  252.         Here  -> newObject
  253.         Copym here  cLen - !    \ store ^class
  254.         copym  DFA  W@            ( dfa datalen )
  255.         Reserve        \ allocate named instances
  256.         copym  IDX-HDR  reserve
  257.         popm IFA @  ?LastIVar not
  258.         IF  0 Pushm Itrav ELSE drop THEN
  259.         classInit
  260.     THEN  ;
  261.  
  262. \ yerk grow zone function
  263. 'c null vect growZone
  264.  
  265. \ ( size -- addr )  acquire a block of nonrelocatable heap
  266. : ovBlock { size -- addr }
  267.     size  newPtr  dup +base 0=
  268.     IF  drop growZone  size newPtr dup +base 0=
  269.         ?error 121
  270.     THEN ;
  271.  
  272. \ build a new object on the heap for class. Use: Heap> className
  273. \ gets heap, and returns  relative  ptr
  274. : (heapObj) { theClass \ dLen obAddr idWid #els -- } 0 -> #els
  275.     theClass dfa w@ -> dlen  theClass dfa 2+ w@ -> idWid
  276.     idWid  IF -> #els THEN
  277.     dLen 4+ idWid IF  idWid #els * 4+ + THEN    \ get total length of obj
  278.     ovBlock  4+ -> obAddr    \ get nonReloc heap, save ptr to cfa
  279.     theClass obAddr cfa !    \ create the class ptr
  280.     idWid  IF  idWid  obAddr dLen + w!  #els obAddr dLen + 2+ w! THEN
  281.     obAddr -> newObject  theClass ifa @  ?LastIvar not
  282.     IF 0 PushM Itrav ELSE Drop THEN classinit obAddr   ;
  283.  
  284. : heap>
  285.     @pfa ?isClass not ?error 122
  286.     state
  287.     IF  Compile lit  ,
  288.         Compile (heapObj) ELSE (heapObj)
  289.     THEN
  290. ; Immediate
  291.  
  292. \ ( -- )  Set CSTATE to compiling a class
  293. : ]C  1 -> Cstate ; Immediate
  294. : C[  0 -> Cstate ; Immediate
  295.  
  296. \ compile hashed word for name at Here
  297. : hash,  @word hash w,  ;
  298.  
  299. $ 81FE0000 variable  aName  0 W,    \ fake name/link
  300.  
  301. \ ( -- )  The super class of Object - top of all inheritance
  302. : Meta
  303.     <[  'Code doClass ^Class CFA !
  304.     here 10 allot  'code objmp swap 10 cmove    \ jump to object code
  305.     aName ,        \ latest method pointer
  306.     0,            \ latest ivar pointer -> SUPER
  307.     0,   ( data len, flags)
  308.     0,   ( super pointer)  HERE -> ^SELF
  309.     hash, SELF    \ SELF ivar
  310.     0, 0, 65535 W,     ( link, ^class, offset)
  311.     Here  -> ^Super    \ save this address for later
  312.     hash, SUPER
  313.     ^self , 0, 65535 W,   ( link, ^class, offset )
  314.  
  315. ^super ' meta ifa !
  316.  
  317. \ ( -- )  Build a class header with its superclass pointer
  318. : <Super
  319.     @pfa dup        \ find the superclass
  320.     dup  ^Super icfa !    \ store superclass in SUPER
  321.     CFA here CFA    \ Set up for cmove to sub class
  322.     26 Cmove        \ create image of superclass header
  323.     ^Class SFA !    \ store superclass pointer
  324.     ^Class  ^Self icfa !    \ store ^class in SELF's icfa
  325.     26 allot
  326.     [Compile]  ]C [Compile]   <[    \ in class, interpret
  327. ; Immediate
  328.  
  329. 'c copym Vect caller    \ late bound reference to calling object
  330.  
  331. \ ( -- b )  true if word at Here is a selector xxx:
  332. : ?isSel  here count 1- + c@ ascii :  =  here c@ 1 > And ;
  333.  
  334. \ get a selector from the input stream
  335. : getSelect
  336.     @word dup c@ 15 >
  337.     ?error 123
  338.     ?isSel 0= ?error 124
  339.     hash  ;
  340.  
  341. \ ( -- )  Build a methods dictionary entry for selector
  342. : :M { \ selID -- }
  343.     ?Class  !Csp  [Compile] ]>
  344.     getSelect -> selID
  345.     selID ^class mfa ((findm))    \ is method already defined?
  346.     IF  dup ^class > verbose or
  347.         IF type# 182 here count type  ( Method redefined )
  348.             space latest id.            \ add class name
  349.             ^class > IF type# 183 ( , within same class **** ) THEN cr
  350.         ELSE drop
  351.         THEN
  352.     THEN
  353.     here  selID w,        \ name is selector's hashed value
  354.     ^class mfa dup @    \ get  mfa, old link
  355.     ,  !    \ establish the links
  356.     \ build methods cfas
  357.     'Code  M0CFA ,  'Code M1CFA ,
  358. ; Immediate
  359.  
  360. \ ( -- pfa tokenID )  Determine type of token referenced by selector.
  361. : refToken
  362.     uFind    \ look for named stack parm
  363.     IF  drop  4 ( parmTyp )
  364.     ELSE  here latest (find)  0=
  365.         ?error 125  drop  ?IsClass
  366.         IF  2 ( classTyp )
  367.         ELSE  ?IsVect
  368.             IF  3 ( vecTyp )
  369.             ELSE  ?IsObj
  370.                 IF  1 ( objTyp )
  371.                 ELSE  ?IsParen
  372.                     IF  5 ( parenType )
  373.                     ELSE  1 ?error 126
  374.                     THEN
  375.                 THEN
  376.             THEN
  377.         THEN
  378.     THEN  ;
  379.  
  380. \ ( objpfa -- a:datalen )
  381. : ^dlen   cfa @ dfa ;
  382.  
  383. \ ( ivarPfa  m1cfa )  compile an Ivar reference
  384. : ivar,    ,   w@ w,   ;    \ | 1cfa | offs |
  385.  
  386. \ ( objPfa  m0cfa )  compile an object ref
  387. : obj,   swap cfa , ,  ;    \ | objCfa | m0cfa |
  388.  
  389. \ ( selID ivPFa )
  390. : ivarRef    Find-Method ivar,   ;
  391.  
  392. \ ( selID -- )  Build a reference to an object or vector
  393. : objRef  refToken
  394.     SELECT{
  395.         0 ( notFnd )    IS{   abort  }END
  396.  
  397.         ( selID objPfa -- )
  398.         1 ( objTyp )    IS{ cfa execute
  399.             Find-Method cfa obj,   }END    \ normal obj ref
  400.  
  401.         2 ( classTyp )  IS{   (FINDM) cfa ,  }END    \ compile m0cfa
  402.  
  403.         ( selPfa  vecPfa -- )
  404.         3 ( vecTyp )    IS{  cfa , Compile (defer) w,  }END
  405.  
  406.         4 ( parmTyp )   IS{  cfa  ,    \ named parm- compile the pickCfa
  407.             Compile (Defer) W, }END    \ auto deferred
  408.  
  409.         5 ( parenType ) IS{  drop pushM  251   }END    \ paren'd defer group
  410.  
  411.     DEFAULT{  abort
  412.     }SELECT  ;
  413.  
  414. \ ( selPfa -- )  Execute using token in stream
  415. : runRef
  416.     @Pfa  drop  refToken
  417.     Select{
  418.         0 ( notFnd )     Is{  abort   }End
  419.         1 ( objTyp )     Is{  cfa execute  Find-Method    }End
  420.         2 ( classTyp )   Is{  (Findm)    }End
  421.  
  422.         ( selID  vecPfa -- )
  423.         3 ( vecTyp )     Is{  cfa execute  Find-Method    }End
  424.  
  425.         4 ( parmTyp )    Is{ abort    }End
  426.  
  427.         \ open bracket denotes a deferred ref to what
  428.         \ the paren'd group puts on the stack at runtime
  429.         5 ( parenType )  Is{  drop  Pushm ' null  }End
  430.  
  431.     Default{ abort
  432.     }Select  cfa  execute ;    \ execute the object, m0cfa
  433.  
  434. \ ================= Selector support ==========================
  435. \ message is the message compiler invoked by using a selector
  436. : message
  437.     state
  438.     IF    \ Compile state
  439.         VFIND    \ instance variable?
  440.         IF   ivarRef    \ ivar reference
  441.         ELSE   objRef    \ compile object/vector reference
  442.         THEN
  443.     ELSE runRef    \ run state - execute object/vector ref
  444.     THEN
  445. ; Immediate
  446.  
  447. \ if parsed word is a message selector, leave cfa of message compiler
  448. \ ( -- selID msgPfa 0 t OR f )
  449. : msgFind
  450.     ?isSel
  451.     IF  Here hash    \ leave selID
  452.         ' message $ c1 true
  453.     ELSE  pfind        \ look for named parms
  454.     THEN   ;
  455.  
  456. 'c msgFind -> Ufind
  457.  
  458. \ Force late binding of method to object, as in SmallTalk
  459. \ a close bracket pops the last selID from the methods stack and
  460. \ compiles a defer: selID.  This will build a deferred reference to the
  461. \ parenthesized group.
  462. : ]    State
  463.     IF  251 ?Pairs  Compile (Defer)
  464.         mdepth 0= ?error 127
  465.         popM   W,    \ Compile | {defer} |SelPfa|
  466.     ELSE  popM  Swap   Find-Method Cfa    \ exec state
  467.         execute
  468.     THEN
  469. ; Immediate
  470.  
  471. \ left bracket has no meaning unless preceded by a selector.
  472. : [  true ?error 128  ; Immediate
  473.  
  474. : ;M   ?Csp  Compile  (;M)   ;  Immediate
  475.  
  476. \ Leave class compilation state, and zero the class ptrs of Self and Super
  477. : ;Class  [Compile] <[  [Compile] C[
  478.         0  ^Super icfa !   0 ^Self icfa ! latest c@ $ df and latest c! ;  Immediate
  479.  
  480. : :Class    [Compile] :    ; Immediate
  481.  
  482. \ ( width -- )  Set a class and its subclasses to indexed
  483. : <Indexed  ?class ^class DFA 2+ W! ;
  484.  
  485. \ ( dim -- )  Set an indexed class to a multi-dimensionality
  486. \ : <Dim
  487. \    ?class ^class DFA 2+ W@ 0= ?error 175    \ misuse of <Dim
  488. \    ^class DFA 2+ c! ;
  489.  
  490. \ ( index -- addr ) ( dlen ^base -M- dlen ^base )  range check
  491. : ?Range    dup 0< >R range? R> or ClassErr" 129  ;
  492.  
  493. \ ( index -- addr )  Return pointer to indexed  element #
  494. : ^Elem
  495.     ?Class    RangeCheck
  496.     IF Compile ?range  THEN
  497.     Compile (^elem)   ;  Immediate
  498.  
  499. \ An object's base addr is always on top of mstack
  500. Create ^base    \ make code word alias
  501.     'Code copym here cfa !
  502.  
  503. \ length does not include cfa
  504. \ ( -- objlen )  compute total length of object
  505. \ - requires obj addr on mstack
  506. : objlen
  507.     copym @dlen copym ^dlen 2+ w@ -dup
  508.     IF idxBase 2- w@ * + 4+ THEN ;
  509.  
  510. \ Define  class init routine
  511. :F classInit    classinit: newObject   ;F
  512.  
  513. \ ( ^ivarLfa -- ) ( ivarOffs -M- )
  514. getSelect classInit: Constant initID
  515. :F initIvar
  516.     initID swap 8+    \ ( selID ivPfa )
  517.     dup cfa @        \ non-0 ^class?
  518.     IF  Find-Method cfa swap W@    ( 0cfa ivOffs )
  519.         copym newObject + +        ( 0cfa ^data )
  520.         swap execute            \ execute the 0cfa
  521.     ELSE  2drop        \ don't try to init Self or Super
  522.     THEN   ;F
  523.  
  524. \ clean up class compiler data on an Abort
  525. ' ;class cfa -> abortVec
  526.  
  527. \ dump will be in the Util module
  528. Forward dmp
  529.  
  530. \ install object builder
  531. ' (build) cfa -> bldvec
  532.  
  533. \ ( -- )  error if object is not indexed
  534. : ?ixObj
  535.     copym  4- @  ?IsClass not swap
  536.     dfa 2+ w@ 0= or classErr" 130 ;
  537.  
  538. : ?ixRange   ?IxObj  ?range  ;
  539. 'c ?ixRange vect ?idx
  540.  
  541. : +range  'c ?ixRange -> ?idx  ;
  542. : -range  'c null -> ?idx ;    \ no range checking
  543.  
  544. :CLASS Object  <Super Meta
  545.  
  546.     :M  AT:    ?idx  At4    ;M   ( index -- val )
  547.     :M  TO:    ?Idx  (^elem) !    ;M   ( val Index -- )
  548.     :M  +TO:   ?idx  ++4   ;M   ( incVal index -- )
  549.     :M  ^ELEM: ?Idx   ^elem        ;M   ( index -- addr )
  550.  
  551.     \ Leave max #elements for array
  552.     :M  LIMIT: ?ixObj limit  ;M    ( -- limit )
  553.  
  554.     \ ( e0 e1... en -- )  indexed PUT: loads array from stack
  555.     :M  PUT:   ?ixObj limit 0
  556.         DO   limit i- 1- (^elem) !  LOOP   ;M
  557.     \ ( -- e0 e1 ...en)  Indexed GET: places elements on stack
  558.     :M  GET:   ?ixObj limit 0 DO i at4  LOOP ;M
  559.  
  560.     :M  CLASS: copym  cfa  @  ;M    \  non-IX - leave class ptr
  561.  
  562.     \ ( -- dataWidth )  leave data width in bytes for array
  563.     :M  WIDTH: ?ixObj  idxBase  4-  W@  ;M
  564.  
  565.     \ ( value -- )  Fill all elements with a value
  566.     :M  FILL:  limit 0 DO  dup i to: self     LOOP drop   ;M
  567.  
  568.     \ ( -- )  Indexed Clear: erases indexed area
  569.     :M  CLEAR:  idxBase  Width: self Limit: Self * Erase ;M
  570.  
  571.     :M  ABS:       (abs)   ;M    \  Absolute copy of mstack
  572.     :M  ADDR:      copym   ;M
  573.  
  574.     \ ( -- addr )  Leave addr of 0th indexed element
  575.     :M  IXADDR:    idxBase   ;M
  576.  
  577.     \ ( -- len )  Return total length of object
  578.     :M  LENGTH:    objlen      ;M
  579.     :M  PRINT:     copym objlen dmp ;M
  580.     :M  DUMP:      print: self  ;M    \ alias for Print:
  581.     :M  CLASSINIT:    ;M    \ null method for object init
  582.  
  583. ;CLASS
  584.  
  585. \ Bytes is used as the allocation primitive for basic classes
  586. : BYTES  ?Class  ' Object <Var  ^Class Dfa W+!  ;
  587.  
  588. \ redefine exit & semicolon to support floating point named args.  IF
  589. \ the word being compiled has float args, the second byte after the cfa
  590. \ will be non-0, containing the arg type bitmask. Dispose of args before exit.
  591. \ Exit uses mexit inside of method defs
  592. \ ( -- )  ERROR if not compiling a new class definition
  593.  
  594. : mexit   ?class  ^class mfa @ 14 + dup c@
  595.     IF  1+ c@  dup IF fkill , w,  ELSE drop THEN
  596.     ELSE  drop 
  597.     THEN  compile (;m) ;  immediate
  598.  
  599. : exit   latest pfa cfa @ dup colCode =
  600.     IF drop Compile ;s
  601.     ELSE  'c doclass >body =
  602.         IF [compile] mexit
  603.         ELSE latest pfa 1+ c@ dup
  604.             IF  fKill , w, ELSE drop THEN
  605.             Compile (semip)
  606.         THEN
  607.     THEN  ;  Immediate
  608.  
  609. : ; ?csp  cState ?error 163            \ Use ;M to terminate methods
  610.     latest c@ $ df and latest c!    \ be sure any smudge is undone
  611.     [Compile] exit [Compile] <[ exit <[  Immediate
  612.  
  613. \ ' Pfind Cfa  ->  Ufind
  614.  
  615. \ define code words to get and set handle sizes
  616. \ ( handle size -- RC )  set handle size with condition code
  617. Create setHSize
  618.     popD0
  619.     popA0
  620.     $ a024 w,    \ call SetHandleSize
  621.     pushD0
  622.     next,
  623.  
  624. \ ( handle -- size )  get handle size
  625. Create getHSize
  626.     popA0
  627.     $ a025 w,    \ call GetHandleSize
  628.     pushD0
  629.     next,
  630.  
  631. <" Struct
  632.